-- Copyright James D. Brock (c) 2018
--
-- Boost Software License - Version 1.0 - August 17th, 2003
-- See accompanying file LICENSE

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}

module Main where

import Data.Maybe
import Data.Monoid
import Data.List
import Data.Function
import Control.Monad
import Data.Default.Class
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.Text as T.Strict
import qualified Data.Text.Lazy.IO as T
import Data.Text.Lazy.Builder (toLazyText, fromText)
import Data.Text.Lazy.Builder.Int (decimal)
import Data.Text.Format as T (right)
import qualified Data.Text.Read as T.Read
import qualified Text.XML as XML
import Text.XML.Cursor as XML
import Control.Monad.Writer.Lazy

-- Data Structures
-- ===============

-- One FIX field for one version of the FIX spec
data Field = Field
        { fname    :: T.Strict.Text -- FIX field name
        , ftype    :: T.Strict.Text -- FIX field type
        , fversion :: T.Strict.Text -- FIX version introduced
        , fdesc    :: T.Strict.Text -- FIX field description
        }
  deriving (Show, Eq)

-- Map of FIX tag to all of the fields names for each version of FIX
type Fields = Map Int Field

-- One Message Type for one version of the FIX spec
data MsgType = MsgType
        { mname    :: T.Strict.Text -- MessageType name
        , mvalue   :: T.Strict.Text -- MessageType field value
        , mversion :: T.Strict.Text -- FIX version introduced
        }

main :: IO ()
main = do

    -- Step 1. Read and parse the spec files

    fixrepoFields <- XML.readFile def "../FIXRepository/Basic/Fields.xml"
    fixrepoMsgs   <- XML.readFile def "../FIXRepository/Basic/Messages.xml"

    -- Extra FIX fields omitted by the spec
    let extraflds = Map.fromList [
            ( 20
            , Field
                { fname    = "ExecTransType"
                , ftype    = "char"
                , fversion = "FIX.4.2" -- just a guess
                , fdesc =
                    "Identifies transaction type\n\n" <>
                    "Valid values:\n" <>
                    "   0 = New\n" <>
                    "   1 = Cancel\n" <>
                    "   2 = Correct\n" <>
                    "   3 = Status\n"
                }
            )
            ]

    -- All the FIX fields from the spec, plus the extraflds
    let fields :: Fields
        fields = foldl' (flip addFieldRepo) extraflds $
            XML.fromDocument fixrepoFields
            $| element "Fields" &/ element "Field"
          where
            -- Read the FIX field information out of one FIX Repository
            -- Fields.xml entry and add it to a Fields Map.
            addFieldRepo :: Cursor -> Fields -> Fields
            addFieldRepo curs = maybe id (uncurry Map.insert) $ do
                fversion <- listToMaybe $ attribute "added" curs
                ftagText <- listToMaybe $ curs $/ element "Tag" &// content
                (ftag,_) <- either (const Nothing) Just $ T.Read.decimal ftagText
                ftype    <- listToMaybe $ curs $/ element "Type" &// content
                fname    <- listToMaybe $ curs $/ element "Name" &// content
                fdesc    <-
                    listToMaybe $ curs $/ element "Description" &// content
                return (ftag, Field{..})

    -- All the FIX MessageTypes from the spec
    let msgTypes :: [MsgType]
        msgTypes = mapMaybe mkMsg $ XML.fromDocument fixrepoMsgs
            $| element "Messages" &/ element "Message"
          where
            -- Make a MsgType from an element of the FIX Repository
            -- Messages.xml file.
            mkMsg :: Cursor -> Maybe MsgType
            mkMsg curs = do
                mname    <- listToMaybe $ curs $/ element "Name" &// content
                mvalue   <- listToMaybe $ curs $/ element "MsgType" &// content
                mversion <- listToMaybe $ attribute "added" curs
                return $ MsgType {..}


    -- Step 2. Write hffix_fields.hpp to stdout.

    T.putStr $ toLazyText $ execWriter $ do

        let tll x = tell $ x <> "\n" -- tell line

        tll "/*!"
        tll "\\file"
        tll "\\brief The hffix_fields.hpp file is generated by the fixspec/spec-parse-fields Haskell program from the FIX Protocol specification documents in the fixspec/ directory."
        tll ""
        tll "Do not edit this file, instead modify the fixspec/spec-parse-fields program and run it from the fixspec/spec-parse-fields directory as shown here. You must have The Haskell Tool Stack https://haskellstack.org installed."
        tll ""
        tll "    cd fixspec/spec-parse-fields && stack run > hffix_fields.hpp && mv hffix_fields.hpp ../../include/hffix_fields.hpp"
        tll ""
        tll "Line comments for each field indicate the data type of the field for each version of the FIX spec in which the field appears."
        tll "*/"
        tll ""
        tll "#ifndef HFFIX_FIELDS_HEADER"
        tll "#define HFFIX_FIELDS_HEADER"
        tll "namespace hffix {"
        tll ""
        tll "/*!"
        tll "\\brief Namespace for all field tag name enums."
        tll "*/"
        tll "namespace tag {"
        tll "enum {"

        -- Write C++ enum of all field tags.
        tell $ flip foldMap (markbounds $ Map.toAscList fields)
            $ \((ftag, Field {..}), _, isLast) ->
                let tagbuild = decimal ftag
                in
                T.right 50 ' ' fname <> " = " <> tagbuild <>
                (if isLast then mempty else ",") <>
                " /*!< " <> tagbuild <> " " <>
                "(" <> fromText ftype <> " " <> fromText fversion <> ") " <>
                -- Double-\n for the description so the line breaks become
                -- paragraph breaks in Doxygen.
                -- HTML entities.
                fromText (T.Strict.replace "\n" "\n\n" $
                          T.Strict.replace "<" "&lt;" $
                          T.Strict.replace ">" "&gt;" fdesc) <>
                "*/\n"


        tll "};"
        tll "} // namespace tag"
        tll ""
        tll "namespace {"
        tll "//! Sorted list of all field tags which are of type Length"
        tll "int length_fields[] = {"

        -- Write C++ array of all field tags for fields of type Length.
        let lengthFields = fields
                & Map.filter ((== "Length") . ftype)
                & Map.delete 9 -- lol BodyLength is not a field length

        tell $ flip foldMap (markbounds $ Map.toAscList lengthFields)
            $ \((ftag, Field{..}), _, isLast) ->
                T.right 35 ' ' ("tag::" <> fromText fname <>
                               (if isLast then "" else ",")) <>
                " // " <> decimal ftag <> " " <>
                "Length" <> " " <> fromText fversion <> "\n"

        tll "};"
        tll "}"
        tll ""
        tll "/*!"
        tll " * \\brief Populate an AssociativeContainer with the names of all the FIX fields."
        tll " *"
        tll " * \\param dictionary A reference to an AssociativeContainer<int, std::string>"
        tll " */"
        tll " template <typename AssociativeContainer> void dictionary_init_field(AssociativeContainer& dictionary) {"

        -- Write C++ init method for a associative container for run-time
        -- field tag lookup.
        tell $ flip foldMap (Map.toAscList fields) $ \(_, Field {..}) ->
            T.right 50 ' ' ("dictionary[tag::" <> fromText fname <> "]") <>
            " = " <>
            T.right 50 ' ' ("\"" <> fromText fname <> "\";") <>
            " // " <> "(" <> fromText ftype <> " " <> fromText fversion <> ")\n"

        -- Write C++ init method for a associative container for run-time
        -- message name lookup.
        tll "}"
        tll "/*!"
        tll " * \\brief Populate an AssociativeContainer with the names of all the FIX message types."
        tll " *"
        tll " * \\param dictionary A reference to an AssociativeContainer<std::string, std::string>"
        tll " */"
        tll " template <typename AssociativeContainer> void dictionary_init_message(AssociativeContainer& dictionary) {"

        tell $ flip foldMap msgTypes $ \MsgType{..} ->
            T.right 25 ' ' ("dictionary[\"" <> fromText mvalue <> "\"]") <>
            " = " <>
            T.right 40 ' ' ("\"" <> fromText mname <> "\";") <>
            " //" <> " (" <> fromText mversion <> ")\n"

        tll "}"
        tll "} // namespace hffix"
        tll "#endif // HFFIX_FIELDS_HEADER"


-- | Annotate elements of a list with Bools, the first of which is True if
-- the element is the head of the list, the second of which is True if the
-- element is the last of the list. Both are True for singleton.
markbounds :: [a] -> [(a, Bool, Bool)]
markbounds [] = []
markbounds [x] = [(x, True, True)]
markbounds (x:xs) = (x, True, False) : tailbound xs
  where
    tailbound [y] = [(y, False, True)]
    tailbound (y:ys) = (y, False, False): tailbound ys
    tailbound [] = []

